Attribute VB_Name = "modCallDispatch"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     FunctionDelegator.bas
'     VBoost.Bas (optional)
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1
'   Conditional Compilation Values:
'     NOVBOOST = 1 'Removes VBoost dependency
'     FUNCTIONDELEGATOR_NOHEAP = 1 'Minimize FunctionDelegator impact
'
' This file is discussed in Chapter 4.
'***************************************************************
Option Explicit
Private GUID_NULL As VBGUID
Private Const DISPID_PROPERTYPUT As Long = -3
Public Const VT_BYREF As Integer = &H4000
Public Enum DispInvokeFlags
    INVOKE_FUNC = 1
    INVOKE_PROPERTYGET = 2
    INVOKE_PROPERTYPUT = 4
    INVOKE_PROPERTYPUTREF = 8
End Enum

Public Function GetMemberID( _
  ByVal pObject As Object, Name As String) As Long
Dim pCallDisp As IDispatchCallable
Dim hr As Long
    #If NOVBOOST Then
        CopyMemory pCallDisp, pObject, 4
        CopyMemory pObject, 0&, 4
    #Else
        VBoost.AssignSwap pCallDisp, pObject
    #End If
    hr = pCallDisp.GetIDsOfNames( _
      GUID_NULL, VarPtr(Name), 1, 0, VarPtr(GetMemberID))
    If hr Then Err.Raise hr
End Function

Public Function CallInvoke( _
  ByVal pObject As Object, _
  ByVal MemberID As Long, _
  ByVal InvokeKind As DispInvokeFlags, _
  ParamArray ReverseArgList() As Variant) As Variant
Dim pSAReverseArgList() As Variant
    'Swap the ParamArray into a normal local variable. I'd like to use
    'DerefEBP to do this, but the stack offsets are 4 higher in the IDE
    'and in pcode than in a native Exe for functions in a standard module,
    'so you can't hard code the correct offset. The following line works
    'in native code, but not in the ide. DerefEBP.bas is required.
    'VBoost.AssignSwap ByVal VarPtrArray(pSAReverseArgList), ByVal DerefEBP.Call(24)
    #If NOVBOOST Then
        Dim pArgList As Long
        pArgList = (VarPtr(InvokeKind) Xor &H80000000) + 4 Xor &H80000000
        CopyMemory pArgList, ByVal pArgList, 4
        CopyMemory ByVal VarPtrArray(pSAReverseArgList), ByVal pArgList, 4
        CopyMemory ByVal pArgList, 0&, 4
    #Else
        With VBoost
            .AssignSwap ByVal VarPtrArray(pSAReverseArgList), ByVal .Deref(.UAdd(VarPtr(InvokeKind), 4))
        End With
    #End If
    'Call the helper with pVarResult set to the address
    'of the return value of this function.
    CallInvokeHelper _
      pObject, MemberID, InvokeKind, VarPtr(CallInvoke), pSAReverseArgList
End Function
Public Function CallInvokeArray( _
  ByVal pObject As Object, _
  ByVal MemberID As Long, _
  ByVal InvokeKind As DispInvokeFlags, _
  ReverseArgList() As Variant) As Variant
    'Call the helper with pVarResult set to the address
    'of the return value of this function.
    CallInvokeHelper _
      pObject, MemberID, InvokeKind, VarPtr(CallInvokeArray), ReverseArgList
End Function
Public Sub CallInvokeSub( _
  ByVal pObject As Object, _
  ByVal MemberID As Long, _
  ByVal InvokeKind As DispInvokeFlags, _
  ParamArray ReverseArgList() As Variant)
Dim pSAReverseArgList() As Variant
    'Swap the ParamArray into a normal local variable. I'd like to use
    'DerefEBP to do this, but the stack offsets are 4 higher in the IDE
    'and in pcode than in a native Exe for functions in a standard module,
    'so you can't hard code the correct offset. The following line works
    'in native code, but not in the ide. DerefEBP.bas is required.
    'VBoost.AssignSwap ByVal VarPtrArray(pSAReverseArgList), ByVal DerefEBP.Call(20)
    #If NOVBOOST Then
        Dim pArgList As Long
        pArgList = (VarPtr(InvokeKind) Xor &H80000000) + 4 Xor &H80000000
        CopyMemory pArgList, ByVal pArgList, 4
        CopyMemory ByVal VarPtrArray(pSAReverseArgList), ByVal pArgList, 4
        CopyMemory ByVal pArgList, 0&, 4
    #Else
        With VBoost
            .AssignSwap ByVal VarPtrArray(pSAReverseArgList), ByVal .Deref(.UAdd(VarPtr(InvokeKind), 4))
        End With
    #End If
    'Call the helper with pVarResult set to 0
    CallInvokeHelper _
      pObject, MemberID, InvokeKind, 0, pSAReverseArgList
End Sub
Public Sub CallInvokeSubArray( _
  ByVal pObject As Object, _
  ByVal MemberID As Long, _
  ByVal InvokeKind As DispInvokeFlags, _
  ReverseArgList() As Variant)
    'Call the helper with pVarResult set to 0
    CallInvokeHelper _
      pObject, MemberID, InvokeKind, 0, ReverseArgList
End Sub

Private Sub CallInvokeHelper(pObject As Object, _
  ByVal MemberID As Long, ByVal InvokeKind As Integer, _
  ByVal pVarResult As Long, ReverseArgList() As Variant)
Dim pCallDisp As IDispatchCallable
Dim hr As Long
Dim ExcepInfo As VBEXCEPINFO
Dim uArgErr As UINT
Dim FDDeferred As FunctionDelegator
Dim pFillExcepInfo As ICallDeferredFillIn
Dim lBoundArgs As Long
Dim dispidNamedArg As DISPID
Dim Params As VBDISPPARAMS
    
    'Fill in fields in the DISPPARAMS structure
    lBoundArgs = LBound(ReverseArgList)
    With Params
        .cArgs = UBound(ReverseArgList) - lBoundArgs + 1
        If .cArgs Then
            .rgvarg = VarPtr(ReverseArgList(lBoundArgs))
        End If
        
        If InvokeKind And _
           (INVOKE_PROPERTYPUT Or INVOKE_PROPERTYPUTREF) Then
            dispidNamedArg = DISPID_PROPERTYPUT
            .cNamedArgs = 1
            .rgdispidNamedArgs = VarPtr(dispidNamedArg)
            'Make sure the RHS parameter is not VT_BYREF.
            VariantCopyInd ReverseArgList(lBoundArgs), _
                           ReverseArgList(lBoundArgs)
        End If
    End With
    
    
    'Get the incoming variable into a type we can call.
    #If NOVBOOST Then
        CopyMemory pCallDisp, pObject, 4
        CopyMemory pObject, 0&, 4
    #Else
        VBoost.AssignSwap pCallDisp, pObject
    #End If
    
    'Make the actual call
    hr = pCallDisp.Invoke(MemberID, GUID_NULL, 0, _
      InvokeKind, Params, pVarResult, ExcepInfo, uArgErr)
    
    'Handle errors
    If hr = DISP_E_EXCEPTION Then
        'ExcepInfo has the information we need
        With ExcepInfo
            If .pfnDeferredFillIn Then
                Set pFillExcepInfo = _
                  InitDelegator(FDDeferred, .pfnDeferredFillIn)
                pFillExcepInfo.Fill ExcepInfo
                .pfnDeferredFillIn = 0
            End If
            Err.Raise .scode, .bstrSource, .bstrDescription, _
              .bstrHelpFile, .dwHelpContext
        End With
    ElseIf hr Then
        Err.Raise hr
    End If
End Sub
